home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / clx-ext.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  27.1 KB  |  594 lines
  1. ;;; -*- Package: Extensions; Log: code.log; Mode: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: clx-ext.lisp,v 1.9 91/12/17 08:21:39 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains code to extend CLX in the CMU Common Lisp environment.
  15. ;;;
  16. ;;; Written by Bill Chiles and Chris Hoover.
  17. ;;;
  18.  
  19. (in-package "EXTENSIONS")
  20.  
  21. (export '(open-clx-display with-clx-event-handling enable-clx-event-handling
  22.       disable-clx-event-handling object-set-event-handler
  23.       default-clx-event-handler
  24.       flush-display-events carefully-add-font-paths
  25.  
  26.       serve-key-press serve-key-release serve-button-press
  27.       serve-button-release serve-motion-notify serve-enter-notify
  28.       serve-leave-notify serve-focus-in serve-focus-out 
  29.       serve-exposure serve-graphics-exposure serve-no-exposure
  30.       serve-visibility-notify serve-create-notify serve-destroy-notify
  31.       serve-unmap-notify serve-map-notify serve-map-request
  32.       serve-reparent-notify serve-configure-notify serve-gravity-notify
  33.       serve-resize-request serve-configure-request serve-circulate-notify
  34.       serve-circulate-request serve-property-notify serve-selection-clear
  35.       serve-selection-request serve-selection-notify serve-colormap-notify
  36.       serve-client-message))
  37.  
  38.  
  39.  
  40. ;;;; OPEN-CLX-DISPLAY.
  41.  
  42. (defun open-clx-display (&optional (string (cdr (assoc :display
  43.                                *environment-list*
  44.                                :test #'eq))))
  45.   "Parses a display specification including display and screen numbers.
  46.    This returns nil when there is no DISPLAY environment variable.  If string
  47.    is non-nil, and any fields are missing in the specification, this signals an
  48.    error.  If you specify a screen, then this sets XLIB:DISPLAY-DEFAULT-SCREEN
  49.    to that screen since CLX initializes this form to the first of
  50.    XLIB:SCREEN-ROOTS.  This returns the display and screen objects."
  51.   (when string
  52.     (let* ((string (coerce string 'simple-string))
  53.        (length (length string))
  54.        (host-name "unix")
  55.        (display-num nil)
  56.        (screen-num nil))
  57.       (declare (simple-string string))
  58.       (let ((colon (position #\: string :test #'char=)))
  59.     (cond ((null colon)
  60.            (error "Missing display number in DISPLAY environment variable."))
  61.           (t
  62.            (unless (zerop colon) (setf host-name (subseq string 0 colon)))
  63.            (let* ((start (1+ colon))
  64.               (first-dot (position #\. string
  65.                        :test #'char= :start start)))
  66.          (cond ((= start (or first-dot length))
  67.             (error "Badly formed display number in DISPLAY ~
  68.                 environment variable."))
  69.                ((null first-dot)
  70.             (setf display-num (parse-integer string :start start)))
  71.                (t
  72.             (setf display-num (parse-integer string :start start
  73.                              :end first-dot))
  74.             (let* ((start (1+ first-dot))
  75.                    (second-dot (position #\. string :test #'char=
  76.                              :start start)))
  77.               (cond ((= start (or second-dot length))
  78.                  (error "Badly formed screen number in ~
  79.                      DISPLAY environment variable."))
  80.                 (t
  81.                  (setf screen-num
  82.                        (parse-integer string :start start
  83.                               :end second-dot)))))))))))
  84.       (let ((display (xlib:open-display host-name :display display-num)))
  85.     (when screen-num
  86.       (let* ((screens (xlib:display-roots display))
  87.          (num-screens (length screens)))
  88.         (when (>= screen-num num-screens)
  89.           (xlib:close-display display)
  90.           (error "No such screen number (~D)." screen-num))
  91.         (setf (xlib:display-default-screen display)
  92.           (elt screens screen-num))))
  93.     (values display (xlib:display-default-screen display))))))
  94.  
  95.  
  96.  
  97. ;;;; Font Path Manipulation
  98.  
  99. (defun carefully-add-font-paths (display font-pathnames
  100.                      &optional (operation :append))
  101.   "Adds the list of font pathnames, Font-Pathnames, to the font path of
  102.   the server Display but does so carefully by checking to make sure that
  103.   the font pathnames are not already on the server's font path.  If any
  104.   of the font pathnames are on the server's font path, they will remain
  105.   in their current positions.  Operation may be specified as either
  106.   :prepend or :append and specifies whether to add the additional font
  107.   pathnames to the beginning or the end of the server's original font
  108.   path."
  109.   (let ((font-path (xlib:font-path display))
  110.     (result ()))
  111.     (dolist (elt font-pathnames)
  112.       (enumerate-search-list (pathname elt)
  113.     (lisp::enumerate-matches (name pathname)
  114.       (unless (member name font-path :test #'string=)
  115.         (push name result)))))
  116.     (when result
  117.       (ecase operation
  118.     (:prepend
  119.      (setf (xlib:font-path display) (revappend result font-path)))
  120.     (:append
  121.      (setf (xlib:font-path display)
  122.            (append font-path (nreverse result))))))))
  123.  
  124.  
  125. ;;;; Enabling and disabling event handling through SYSTEM:SERVE-EVENT.
  126.  
  127. (defvar *clx-fds-to-displays* (make-hash-table :test #'eql)
  128.   "This is a hash table that maps CLX file descriptors to CLX display
  129.    structures.  For every CLX file descriptor know to SYSTEM:SERVE-EVENT,
  130.    there must be a mapping from that file descriptor to its CLX display
  131.    structure when events are handled via SYSTEM:SERVE-EVENT.")
  132.  
  133. (defmacro with-clx-event-handling ((display handler) &rest body)
  134.   "Evaluates body in a context where events are handled for the display
  135.    by calling handler on the display.  This destroys any previously established
  136.    handler for display."
  137.   `(unwind-protect
  138.        (progn
  139.      (enable-clx-event-handling ,display ,handler)
  140.      ,@body)
  141.      (disable-clx-event-handling ,display)))
  142.  
  143. ;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in
  144. ;;; *display-event-handlers*.  It also uses SYSTEM:ADD-FD-HANDLER to have
  145. ;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows
  146. ;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a
  147. ;;; file descriptor, the file descriptor is also mapped to the display in
  148. ;;; *clx-fds-to-displays*, so the user's handler can be called on the display.
  149. ;;;
  150. (defun enable-clx-event-handling (display handler)
  151.   "After calling this, when SYSTEM:SERVE-EVENT notices input on display's
  152.    connection to the X11 server, handler is called on the display.  Handler
  153.    is invoked in a dynamic context with an error handler bound that will
  154.    flush all events from the display and return.  By returning, it declines
  155.    to handle the error, but it will have cleared all events; thus, entering
  156.    the debugger will not result in infinite errors due to streams that wait
  157.    via SYSTEM:SERVE-EVENT for input.  Calling this repeatedly on the same
  158.    display establishes handler as a new handler, replacing any previous one
  159.    for display."
  160.   (check-type display xlib:display)
  161.   (let ((change-handler (assoc display *display-event-handlers*)))
  162.     (if change-handler
  163.     (setf (cdr change-handler) handler)
  164.     (let ((fd (fd-stream-fd (xlib::display-input-stream display))))
  165.       (system:add-fd-handler fd :input #'call-display-event-handler)
  166.       (setf (gethash fd *clx-fds-to-displays*) display)
  167.       (push (cons display handler) *display-event-handlers*)))))
  168.  
  169. ;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps
  170. ;;; the display to its handler.  If we can't find the display, we remove the
  171. ;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the
  172. ;;; display from *display-event-handlers*.  This is necessary to try to keep
  173. ;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and
  174. ;;; over.  This is possible since many CMU Common Lisp streams loop over
  175. ;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are
  176. ;;; possible.
  177. ;;;
  178. (defun call-display-event-handler (file-descriptor)
  179.   (let ((display (gethash file-descriptor *clx-fds-to-displays*)))
  180.     (unless display
  181.       (system:invalidate-descriptor file-descriptor)
  182.       (setf *display-event-handlers*
  183.         (delete file-descriptor *display-event-handlers*
  184.             :key #'(lambda (d/h)
  185.                  (fd-stream-fd
  186.                   (xlib::display-input-stream
  187.                    (car d/h))))))
  188.       (error "File descriptor ~S not associated with any CLX display.~%~
  189.                 It has been removed from system:serve-event's knowledge."
  190.          file-descriptor))
  191.     (let ((handler (cdr (assoc display *display-event-handlers*))))
  192.       (unless handler
  193.     (flush-display-events display)
  194.     (error "Display ~S not associated with any event handler." display))
  195.       (handler-bind ((error #'(lambda (condx)
  196.                 (declare (ignore condx))
  197.                 (flush-display-events display))))
  198.     (funcall handler display)))))
  199.  
  200. (defun disable-clx-event-handling (display)
  201.   "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING."
  202.   (setf *display-event-handlers*
  203.     (delete display *display-event-handlers* :key #'car))
  204.   (let ((fd (fd-stream-fd (xlib::display-input-stream display))))
  205.     (remhash fd *clx-fds-to-displays*)
  206.     (system:invalidate-descriptor fd)))
  207.  
  208.  
  209.  
  210. ;;;; Object set event handling.
  211.  
  212. ;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear
  213. ;;; events on the display before signalling any errors.  This is necessary
  214. ;;; since reading on certain CMU Common Lisp streams involves SERVER, and
  215. ;;; getting an error while trying to handle an event causes repeated attempts
  216. ;;; to handle the same event.
  217. ;;;
  218. (defvar *process-clx-event-display* nil)
  219.  
  220. (defvar *object-set-event-handler-print* nil)
  221.  
  222. (proclaim '(declaration values))
  223.  
  224. (defun object-set-event-handler (display)
  225.   "This display event handler uses object sets to map event windows cross
  226.    event types to handlers.  It uses XLIB:EVENT-CASE to bind all the slots
  227.    of each event, calling the handlers on all these values in addition to
  228.    the event key and send-event-p.  Describe EXT:SERVE-MUMBLE, where mumble
  229.    is an event keyword name for the exact order of arguments.
  230.    :mapping-notify and :keymap-notify events are ignored since they do not
  231.    occur on any particular window.  After calling a handler, each branch
  232.    returns t to discard the event.  While the handler is executing, all
  233.    errors go through a handler that flushes all the display's events and
  234.    returns.  This prevents infinite errors since the debug and terminal
  235.    streams loop over SYSTEM:SERVE-EVENT.  This function returns t if there
  236.    were some event to handle, nil otherwise.  It returns immediately if
  237.    there is no event to handle."
  238.   (macrolet ((dispatch (event-key &rest args)
  239.            `(multiple-value-bind (object object-set)
  240.                      (lisp::map-xwindow event-window)
  241.           (unless object
  242.             (cond ((not (typep event-window 'xlib:window))
  243.                (xlib:discard-current-event display)
  244.                (warn "Discarding ~S event on non-window ~S."
  245.                  ,event-key event-window)
  246.                (return-from object-set-event-handler nil))
  247.               (t
  248.                (flush-display-events display)
  249.                (error "~S not a known X window.~%~
  250.                        Received event ~S."
  251.                   event-window ,event-key))))
  252.           (handler-bind ((error #'(lambda (condx)
  253.                         (declare (ignore condx))
  254.                         (flush-display-events display))))
  255.             (when *object-set-event-handler-print*
  256.               (print ,event-key) (force-output))
  257.             (funcall (gethash ,event-key
  258.                       (lisp::object-set-table object-set)
  259.                       (lisp::object-set-default-handler
  260.                        object-set))
  261.                  object ,event-key
  262.                  ,@args))
  263.           (setf result t))))
  264.     (let ((*process-clx-event-display* display)
  265.       (result nil))
  266.       (xlib:event-case (display :timeout 0)
  267.     ((:KEY-PRESS :KEY-RELEASE :BUTTON-PRESS :BUTTON-RELEASE)
  268.          (event-key event-window root child same-screen-p
  269.           x y root-x root-y state time code send-event-p)
  270.      (dispatch event-key event-window root child same-screen-p
  271.            x y root-x root-y state time code send-event-p))
  272.     (:MOTION-NOTIFY (event-window root child same-screen-p
  273.              x y root-x root-y state time hint-p send-event-p)
  274.      (dispatch :motion-notify event-window root child same-screen-p
  275.            x y root-x root-y state time hint-p send-event-p))
  276.     (:ENTER-NOTIFY (event-window root child same-screen-p
  277.             x y root-x root-y state time mode kind send-event-p)
  278.      (dispatch :enter-notify event-window root child same-screen-p
  279.            x y root-x root-y state time mode kind send-event-p))
  280.     (:LEAVE-NOTIFY (event-window root child same-screen-p
  281.             x y root-x root-y state time mode kind send-event-p)
  282.      (dispatch :leave-notify event-window root child same-screen-p
  283.            x y root-x root-y state time mode kind send-event-p))
  284.     (:EXPOSURE (event-window x y width height count send-event-p)
  285.      (dispatch :exposure event-window x y width height count send-event-p))
  286.     (:GRAPHICS-EXPOSURE (event-window x y width height count major minor
  287.                  send-event-p)
  288.      (dispatch :graphics-exposure event-window x y width height
  289.            count major minor send-event-p))
  290.     (:NO-EXPOSURE (event-window major minor send-event-p)
  291.      (dispatch :no-exposure event-window major minor send-event-p))
  292.     (:FOCUS-IN (event-window mode kind send-event-p)
  293.      (dispatch :focus-in event-window mode kind send-event-p))
  294.     (:FOCUS-OUT (event-window mode kind send-event-p)
  295.      (dispatch :focus-out event-window mode kind send-event-p))
  296.     (:KEYMAP-NOTIFY ()
  297.      (warn "Ignoring keymap notify event.")
  298.      (when *object-set-event-handler-print*
  299.        (print :keymap-notify) (force-output))
  300.      (setf result t))
  301.     (:VISIBILITY-NOTIFY (event-window state send-event-p)
  302.      (dispatch :visibility-notify event-window state send-event-p))
  303.     (:CREATE-NOTIFY (event-window window x y width height border-width
  304.              override-redirect-p send-event-p)
  305.      (dispatch :create-notify event-window window x y width height
  306.            border-width override-redirect-p send-event-p))
  307.     (:DESTROY-NOTIFY (event-window window send-event-p)
  308.      (dispatch :destroy-notify event-window window send-event-p))
  309.     (:UNMAP-NOTIFY (event-window window configure-p send-event-p)
  310.      (dispatch :unmap-notify event-window window configure-p send-event-p))
  311.     (:MAP-NOTIFY (event-window window override-redirect-p send-event-p)
  312.      (dispatch :map-notify event-window window override-redirect-p
  313.            send-event-p))
  314.     (:MAP-REQUEST (event-window window send-event-p)
  315.      (dispatch :map-request event-window window send-event-p))
  316.     (:REPARENT-NOTIFY (event-window window parent x y override-redirect-p
  317.                send-event-p)
  318.      (dispatch :reparent-notify event-window window parent x y
  319.            override-redirect-p send-event-p))
  320.     (:CONFIGURE-NOTIFY (event-window window x y width height border-width
  321.                 above-sibling override-redirect-p send-event-p)
  322.      (dispatch :configure-notify event-window window x y width height
  323.            border-width above-sibling override-redirect-p
  324.            send-event-p))
  325.     (:GRAVITY-NOTIFY (event-window window x y send-event-p)
  326.      (dispatch :gravity-notify event-window window x y send-event-p))
  327.     (:RESIZE-REQUEST (event-window width height send-event-p)
  328.      (dispatch :resize-request event-window width height send-event-p))
  329.     (:CONFIGURE-REQUEST (event-window window x y width height border-width
  330.                  stack-mode above-sibling value-mask send-event-p)
  331.      (dispatch :configure-request event-window window x y width height
  332.            border-width stack-mode above-sibling value-mask
  333.            send-event-p))
  334.     (:CIRCULATE-NOTIFY (event-window window place send-event-p)
  335.      (dispatch :circulate-notify event-window window place send-event-p))
  336.     (:CIRCULATE-REQUEST (event-window window place send-event-p)
  337.      (dispatch :circulate-request event-window window place send-event-p))
  338.     (:PROPERTY-NOTIFY (event-window atom state time send-event-p)
  339.      (dispatch :property-notify event-window atom state time send-event-p))
  340.     (:SELECTION-CLEAR (event-window selection time send-event-p)
  341.      (dispatch :selection-notify event-window selection time send-event-p))
  342.     (:SELECTION-REQUEST (event-window requestor selection target property
  343.                  time send-event-p)
  344.      (dispatch :selection-request event-window requestor selection target
  345.            property time send-event-p))
  346.     (:SELECTION-NOTIFY (event-window selection target property time
  347.                 send-event-p)
  348.      (dispatch :selection-notify event-window selection target property time
  349.            send-event-p))
  350.     (:COLORMAP-NOTIFY (event-window colormap new-p installed-p send-event-p)
  351.      (dispatch :colormap-notify event-window colormap new-p installed-p
  352.            send-event-p))
  353.     (:MAPPING-NOTIFY (request)
  354.      (warn "Ignoring mapping notify event -- ~S." request)
  355.      (when *object-set-event-handler-print*
  356.        (print :mapping-notify) (force-output))
  357.      (setf result t))
  358.     (:CLIENT-MESSAGE (event-window format data send-event-p)
  359.      (dispatch :client-message event-window format data send-event-p)))
  360.       result)))
  361.  
  362. (defun default-clx-event-handler (object event-key event-window &rest ignore)
  363.   (declare (ignore ignore))
  364.   (flush-display-events *process-clx-event-display*)
  365.   (error "No handler for event type ~S on ~S in ~S."
  366.      event-key object (lisp::map-xwindow event-window)))
  367.  
  368. (defun flush-display-events (display)
  369.   "Dumps all the events in display's event queue including the current one
  370.    in case this is called from within XLIB:EVENT-CASE, etc."
  371.   (xlib:discard-current-event display)
  372.   (xlib:event-case (display :discard-p t :timeout 0)
  373.     (t () nil)))
  374.  
  375.  
  376.  
  377. ;;;; Key and button service.
  378.  
  379. (defun serve-key-press (object-set fun)
  380.   "Associate a method in the object-set with :key-press events.  The method
  381.    is called on the object the event occurred, event key, event window, root,
  382.    child, same-screen-p, x, y, root-x, root-y, state, time, code, and
  383.    send-event-p."
  384.   (setf (gethash :key-press (lisp::object-set-table object-set)) fun))
  385.  
  386. (defun serve-key-release (object-set fun)
  387.   "Associate a method in the object-set with :key-release events.  The method
  388.    is called on the object the event occurred, event key, event window, root,
  389.    child, same-screen-p, x, y, root-x, root-y, state, time, code, and
  390.    send-event-p."
  391.   (setf (gethash :key-release (lisp::object-set-table object-set)) fun))
  392.  
  393. (defun serve-button-press (object-set fun)
  394.   "Associate a method in the object-set with :button-press events.  The method
  395.    is called on the object the event occurred, event key, event window, root,
  396.    child, same-screen-p, x, y, root-x, root-y, state, time, code, and
  397.    send-event-p."
  398.   (setf (gethash :button-press (lisp::object-set-table object-set)) fun))
  399.  
  400. (defun serve-button-release (object-set fun)
  401.   "Associate a method in the object-set with :button-release events.  The
  402.    method is called on the object the event occurred, event key, event window,
  403.    root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and
  404.    send-event-p."
  405.   (setf (gethash :button-release (lisp::object-set-table object-set)) fun))
  406.  
  407.  
  408.  
  409. ;;;; Mouse service.
  410.  
  411. (defun serve-motion-notify (object-set fun)
  412.   "Associate a method in the object-set with :motion-notify events.  The method
  413.    is called on the object the event occurred, event key, event window, root,
  414.    child, same-screen-p, x, y, root-x, root-y, state, time, hint-p, and
  415.    send-event-p."
  416.   (setf (gethash :motion-notify (lisp::object-set-table object-set)) fun))
  417.  
  418. (defun serve-enter-notify (object-set fun)
  419.   "Associate a method in the object-set with :enter-notify events.  The method
  420.    is called on the object the event occurred, event key, event window, root,
  421.    child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
  422.    and send-event-p."
  423.   (setf (gethash :enter-notify (lisp::object-set-table object-set)) fun))
  424.  
  425. (defun serve-leave-notify (object-set fun)
  426.   "Associate a method in the object-set with :leave-notify events.  The method
  427.    is called on the object the event occurred, event key, event window, root,
  428.    child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
  429.    and send-event-p."
  430.   (setf (gethash :leave-notify (lisp::object-set-table object-set)) fun))
  431.  
  432.  
  433.  
  434. ;;;; Keyboard service.
  435.  
  436. (defun serve-focus-in (object-set fun)
  437.   "Associate a method in the object-set with :focus-in events.  The method
  438.    is called on the object the event occurred, event key, event window, mode,
  439.    kind, and send-event-p."
  440.   (setf (gethash :focus-in (lisp::object-set-table object-set)) fun))
  441.  
  442. (defun serve-focus-out (object-set fun) 
  443.   "Associate a method in the object-set with :focus-out events.  The method
  444.    is called on the object the event occurred, event key, event window, mode,
  445.    kind, and send-event-p."
  446.   (setf (gethash :focus-out (lisp::object-set-table object-set)) fun))
  447.  
  448.  
  449.  
  450. ;;;; Exposure service.
  451.  
  452. (defun serve-exposure (object-set fun)
  453.   "Associate a method in the object-set with :exposure events.  The method
  454.    is called on the object the event occurred, event key, event window, x, y,
  455.    width, height, count, and send-event-p."
  456.   (setf (gethash :exposure (lisp::object-set-table object-set)) fun))
  457.  
  458. (defun serve-graphics-exposure (object-set fun)
  459.   "Associate a method in the object-set with :graphics-exposure events.  The
  460.    method is called on the object the event occurred, event key, event window,
  461.    x, y, width, height, count, major, minor, and send-event-p."
  462.   (setf (gethash :graphics-exposure (lisp::object-set-table object-set)) fun))
  463.  
  464. (defun serve-no-exposure (object-set fun)
  465.   "Associate a method in the object-set with :no-exposure events.  The method
  466.    is called on the object the event occurred, event key, event window, major,
  467.    minor, and send-event-p."
  468.   (setf (gethash :no-exposure (lisp::object-set-table object-set)) fun))
  469.   
  470.  
  471.  
  472. ;;;; Structure service.
  473.  
  474. (defun serve-visibility-notify (object-set fun)
  475.   "Associate a method in the object-set with :visibility-notify events.  The
  476.    method is called on the object the event occurred, event key, event window,
  477.    state, and send-event-p."
  478.   (setf (gethash :visibility-notify (lisp::object-set-table object-set)) fun))
  479.  
  480. (defun serve-create-notify (object-set fun)
  481.   "Associate a method in the object-set with :create-notify events.  The
  482.    method is called on the object the event occurred, event key, event window,
  483.    window, x, y, width, height, border-width, override-redirect-p, and
  484.    send-event-p."
  485.   (setf (gethash :create-notify (lisp::object-set-table object-set)) fun))
  486.  
  487. (defun serve-destroy-notify (object-set fun)
  488.   "Associate a method in the object-set with :destroy-notify events.  The
  489.    method is called on the object the event occurred, event key, event window,
  490.    window, and send-event-p."
  491.   (setf (gethash :destroy-notify (lisp::object-set-table object-set)) fun))
  492.  
  493. (defun serve-unmap-notify (object-set fun)
  494.   "Associate a method in the object-set with :unmap-notify events.  The
  495.    method is called on the object the event occurred, event key, event window,
  496.    window, configure-p, and send-event-p."
  497.   (setf (gethash :unmap-notify (lisp::object-set-table object-set)) fun))
  498.  
  499. (defun serve-map-notify (object-set fun)
  500.   "Associate a method in the object-set with :map-notify events.  The
  501.    method is called on the object the event occurred, event key, event window,
  502.    window, override-redirect-p, and send-event-p."
  503.   (setf (gethash :map-notify (lisp::object-set-table object-set)) fun))
  504.  
  505. (defun serve-map-request (object-set fun)
  506.   "Associate a method in the object-set with :map-request events.  The
  507.    method is called on the object the event occurred, event key, event window,
  508.    window, and send-event-p."
  509.   (setf (gethash :map-request (lisp::object-set-table object-set)) fun))
  510.  
  511. (defun serve-reparent-notify (object-set fun)
  512.   "Associate a method in the object-set with :reparent-notify events.  The
  513.    method is called on the object the event occurred, event key, event window,
  514.    window, parent, x, y, override-redirect-p, and send-event-p."
  515.   (setf (gethash :reparent-notify (lisp::object-set-table object-set)) fun))
  516.  
  517. (defun serve-configure-notify (object-set fun)
  518.   "Associate a method in the object-set with :configure-notify events.  The
  519.    method is called on the object the event occurred, event key, event window,
  520.    window, x, y, width, height, border-width, above-sibling,
  521.    override-redirect-p, and send-event-p."
  522.   (setf (gethash :configure-notify (lisp::object-set-table object-set)) fun))
  523.  
  524. (defun serve-gravity-notify (object-set fun)
  525.   "Associate a method in the object-set with :gravity-notify events.  The
  526.    method is called on the object the event occurred, event key, event window,
  527.    window, x, y, and send-event-p."
  528.   (setf (gethash :gravity-notify (lisp::object-set-table object-set)) fun))
  529.  
  530. (defun serve-resize-request (object-set fun)
  531.   "Associate a method in the object-set with :resize-request events.  The
  532.    method is called on the object the event occurred, event key, event window,
  533.    width, height, and send-event-p."
  534.   (setf (gethash :resize-request (lisp::object-set-table object-set)) fun))
  535.  
  536. (defun serve-configure-request (object-set fun)
  537.   "Associate a method in the object-set with :configure-request events.  The
  538.    method is called on the object the event occurred, event key, event window,
  539.    window, x, y, width, height, border-width, stack-mode, above-sibling,
  540.    value-mask, and send-event-p."
  541.   (setf (gethash :configure-request (lisp::object-set-table object-set)) fun))
  542.  
  543. (defun serve-circulate-notify (object-set fun)
  544.   "Associate a method in the object-set with :circulate-notify events.  The
  545.    method is called on the object the event occurred, event key, event window,
  546.    window, place, and send-event-p."
  547.   (setf (gethash :circulate-notify (lisp::object-set-table object-set)) fun))
  548.  
  549. (defun serve-circulate-request (object-set fun)
  550.   "Associate a method in the object-set with :circulate-request events.  The
  551.    method is called on the object the event occurred, event key, event window,
  552.    window, place, and send-event-p."
  553.   (setf (gethash :circulate-request (lisp::object-set-table object-set)) fun))
  554.  
  555.  
  556.  
  557. ;;;; Misc. service.
  558.  
  559. (defun serve-property-notify (object-set fun)
  560.   "Associate a method in the object-set with :property-notify events.  The
  561.    method is called on the object the event occurred, event key, event window,
  562.    atom, state, time, and send-event-p."
  563.   (setf (gethash :property-notify (lisp::object-set-table object-set)) fun))
  564.  
  565. (defun serve-selection-clear (object-set fun)
  566.   "Associate a method in the object-set with :selection-clear events.  The
  567.    method is called on the object the event occurred, event key, event window,
  568.    selection, time, and send-event-p."
  569.   (setf (gethash :selection-clear (lisp::object-set-table object-set)) fun))
  570.  
  571. (defun serve-selection-request (object-set fun)
  572.   "Associate a method in the object-set with :selection-request events.  The
  573.    method is called on the object the event occurred, event key, event window,
  574.    requestor, selection, target, property, time, and send-event-p."
  575.   (setf (gethash :selection-request (lisp::object-set-table object-set)) fun))
  576.  
  577. (defun serve-selection-notify (object-set fun)
  578.   "Associate a method in the object-set with :selection-notify events.  The
  579.    method is called on the object the event occurred, event key, event window,
  580.    selection, target, property, time, and send-event-p."
  581.   (setf (gethash :selection-notify (lisp::object-set-table object-set)) fun))
  582.  
  583. (defun serve-colormap-notify (object-set fun)
  584.   "Associate a method in the object-set with :colormap-notify events.  The
  585.    method is called on the object the event occurred, event key, event window,
  586.    colormap, new-p, installed-p, and send-event-p."
  587.   (setf (gethash :colormap-notify (lisp::object-set-table object-set)) fun))
  588.  
  589. (defun serve-client-message (object-set fun)
  590.   "Associate a method in the object-set with :client-message events.  The
  591.    method is called on the object the event occurred, event key, event window,
  592.    format, data, and send-event-p."
  593.   (setf (gethash :client-message (lisp::object-set-table object-set)) fun))
  594.